home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / TRIANG.LSP < prev   
Text File  |  1980-01-01  |  2KB  |  60 lines
  1. ; TRIANG
  2.  
  3. (defvar board '#(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1))
  4. (defvar sequence (make-array 14. ':initial-element 0.))
  5. (defvar *a* '#(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4
  6.           4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6))
  7. (defvar *b* '#(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
  8.           2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5))
  9. (defvar *c* '#(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
  10.           1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4))
  11. (defvar answer)
  12. (defvar final)
  13.  
  14. (defun last-position ()
  15.   (do ((i 1 (1+ i)))
  16.       ((= i 16.) 0)
  17.     (if (= 1 (aref board i))
  18.     (return i))))
  19.  
  20. (defun try (i depth)
  21.        (cond ((= depth 14)
  22.           (let ((lp (last-position)))
  23.            (unless (member lp final)
  24.              (push lp final)))
  25.           (push (cdr (coerce sequence 'list)) answer) t)
  26.          ((and (= 1 (aref board (aref *a* i)))
  27.            (= 1 (aref board (aref *b* i)))
  28.            (= 0 (aref board (aref *c* i))))
  29.           (setf (aref board (aref *a* i)) 0)
  30.           (setf (aref board (aref *b* i)) 0)
  31.           (setf (aref board (aref *c* i)) 1)
  32.           (setf (aref sequence depth) i)
  33.           (do ((j 0 (1+ j))
  34.            (depth (1+ depth)))
  35.           ((or (= j 36.)
  36.                (try j depth)) ()))
  37.           (setf (aref board (aref *a* i)) 1)
  38.           (setf (aref board (aref *b* i)) 1)
  39.           (setf (aref board (aref *c* i)) 0) ())))
  40.  
  41. (defun gogogo (i)
  42.   (dotimes (j 16)
  43.     (setf (aref board j) 1))
  44.   (setf (aref board 5) 0)
  45.   (let ((answer ())
  46.     (final ()))
  47.     (try i 1)))
  48.  
  49. (define-timer triang "Triang" (gogogo 22.))
  50. (qa-attempt "Triang" (gogogo 22.) nil)
  51.  
  52. (defun triang-test ()
  53.   (dotimes (j 16)
  54.     (setf (aref board j) 1))
  55.   (setf (aref board 5) 0)
  56.   (let ((answer ())
  57.     (final ()))
  58.     (try 22. 1)
  59.     (= (length answer) 775.)))
  60.